home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol030 / cryptogr.bas < prev    next >
Encoding:
BASIC Source File  |  1987-01-11  |  7.0 KB  |  155 lines
  1. 10 ' K********  CRYPTOGRAM **********
  2. 20 DEF SEG = &HB000
  3. 25 KEY OFF
  4. 30 SP$ = " ":BLANK$ = "                                        "
  5. 35 TODSK$ = "N"
  6. 40 CLS:COLOR 7,0
  7. 50 LOCATE ,33:PRINT "Walt Johnson's "
  8. 60 LOCATE ,26:PRINT "Program to help you to solve"
  9. 70 PRINT:COLOR 15,0
  10. 80 LOCATE ,34:PRINT "CRYPTOGRAMS"
  11. 90 COLOR 7,0:LOCATE 7
  12. 100 PRINT "          Pick a source of input for your cryptogram.    "
  13. 110 PRINT
  14. 120 PRINT "            K - Keyboard - Enter the cryptogram from the keyboard.  "
  15. 130 PRINT
  16. 140 PRINT "            D - Disk     - Accept a cryptogram from the Disk file.  "
  17. 145 LOCATE 13,11
  18. 150 INPUT X$
  19. 170 IF X$ = "D" OR X$ = "d" GOTO 1130
  20. 190 IF X$ = "K" OR X$ = "k" GOTO 230
  21. 210 GOTO 150
  22. 220 ' **********  GET THE CODE FROM THE KEYBOARD  **********
  23. 230 LOCATE 7
  24. 232 TODSK$ = "Y"
  25. 233 PRINT  "Please enter the data that you want to decode, up to 3 lines (240 characters).  "
  26. 234 LOCATE 9,1:PRINT SPC(78)
  27. 235 LOCATE 11,1:PRINT SPC(78)
  28. 236 LOCATE 13,1:PRINT SPC(78)
  29. 240 LOCATE 19,1:PRINT SPC(79):PRINT SPC(79)
  30. 245 LOCATE 15,1:LINE INPUT CRYPTO$
  31. 250 ' ***** ROUTINE TO MAKE ALL LOWER CASE LETTERS INTO UPPER CASE *****
  32. 260 FOR X=1 TO LEN(CRYPTO$)
  33. 270    Y = ASC(MID$(CRYPTO$,X,1))
  34. 280 IF (Y>96) AND (Y<123) THEN LET Y = Y-32:MID$(CRYPTO$,X,1) = CHR$(Y)
  35. 290 NEXT X
  36. 310 LOCATE 15:PRINT CRYPTO$;SPC(79 - POS(0)):PRINT SPC(79)
  37. 320 LOCATE 8:FOR X=1 TO 5:PRINT SPC(79):NEXT X
  38. 328 ' **********  MAKE CORRECTIONS TO THE CODE  **********
  39. 330 LOCATE 7,1:PRINT "Any corrections? (Y/N) "; SPC(56):LOCATE 7,25
  40. 340 INPUT ANS$:ANS$ = LEFT$(ANS$,1)
  41. 350 IF ANS$ <> "N" AND ANS$ <> "n"  THEN LOCATE 7,1:TODSK$ = "Y":PRINT "Change the Cryptogram and move the cursor to the end before pressing enter.      ":FOR A=1 TO 5:PRINT SPC(79):NEXT:LOCATE 15,1:GOTO 240
  42. 358 '   ********* CORRECT THE PROBLEM OF A WORD SPLIT ONTO TWO LINES ****
  43. 360 Y=80: GOSUB 410
  44. 370 Y=160: GOSUB 410
  45. 380 Y=240:GOSUB 410
  46. 390 GOTO 490
  47. 410    IF LEN(CRYPTO$) < Y+1 THEN GOTO 480
  48. 420    IF MID$(CRYPTO$,Y,1) = " "  THEN GOTO 480
  49. 430    IF MID$(CRYPTO$,Y+1,1) = " "  THEN GOTO 480
  50. 440    FOR X=Y TO Y-20 STEP -1
  51. 450       IF MID$(CRYPTO$,X,1) = SP$ THEN CRYPTO$=MID$(CRYPTO$,1,X) +                          MID$(BLANK$,1,Y-X) + MID$(CRYPTO$,X+1) :GOTO 480
  52. 460    NEXT X
  53. 470 PRINT "CANNOT HANDLE WORDS > 20 CHAR AT END OF THE LINE. FIX WITH CHANGE ROUTINE.":FOR ZX = 1 TO 4000:NEXT ZX:GOTO 310
  54. 480 RETURN
  55. 488 ' ****** PUT THE CODE ON DISK? Only if from keyboard or changed. ******
  56. 490 FOR X=1 TO 2:PRINT SPC(79):NEXT
  57. 495 IF TODSK$ = "N" THEN GOTO 540
  58. 500 LOCATE 7,1:PRINT "Would you like this cryptogram stored on disk? (Y/N)";SPC(20):FOR X=1 TO 6:PRINT SPC(79):NEXT:LOCATE 7,55
  59. 510 INPUT X$:IF X$="y" OR X$ = "Y" THEN GOTO 520 ELSE GOTO 540
  60. 520 OPEN "crypdata" AS #1 LEN=256:FIELD #1, 255 AS C$
  61. 522 LASTCR = LOF(1)/256:INPUT "Which slot? Key 0 for the next available new location.",NUM%
  62. 524 LSET C$ = CRYPTO$:IF NUM% > 0 THEN PUT #1, NUM% ELSE IF NUM% =0 THEN PUT #1,(LASTCR + 1)
  63. 530 CLOSE
  64. 538 ' ****** PUT THE CRYPTOGRAM ON THE SCREEN IN DECODE POSITION ******
  65. 540 CLS :LOCATE ,35:PRINT "CRYPTOGRAM"
  66. 550 LOCATE 5,1
  67. 560 PRINT LEFT$(CRYPTO$,80)
  68. 570 IF LEN(CRYPTO$) < 81 THEN GOTO 630
  69. 580 LOCATE 9,1:PRINT MID$(CRYPTO$,81,80)
  70. 590 IF LEN(CRYPTO$) < 161 THEN GOTO 630
  71. 600 LOCATE 13,1:PRINT MID$(CRYPTO$,161,80)
  72. 610 IF LEN(CRYPTO$) < 241 THEN GOTO 630
  73. 620 LOCATE 17,1:PRINT MID$(CRYPTO$,241)
  74. 630 PRINT SPC(79)
  75. 640 COLOR 15
  76. 650 LOCATE 23,1
  77. 660 PRINT "  A  B  C  D  E  F  G  H  I  J  K  L  M  N  O  P  Q  R  S  T  U  V  W  X  Y  Z"
  78. 661 IF MID$(CRYPTO$,241,10) = MID$(BLANK$,1,10) THEN CRYPTO$ = LEFT$(CRYPTO$,240)
  79. 662 IF MID$(CRYPTO$,161,10) = MID$(BLANK$,1,10) THEN CRYPTO$ = LEFT$(CRYPTO$,160)
  80. 663 IF MID$(CRYPTO$,81,10) = MID$(BLANK$,1,10) THEN CRYPTO$ = LEFT$(CRYPTO$,80)
  81. 670 LOCATE 4,1,1:'LOCATE THE CURSOR OVER THE FIRST CHAR OF THE CODE
  82. 678 ' ******   GET AN INPUT KEYSTROKE   ******
  83. 680 X$ = INKEY$
  84. 690 IF LEN(X$)= 0 THEN GOTO 680 ELSE LOCATE ,,0 'WAIT FOR A KEY STROKE
  85. 700 CH = ASC(X$):IF (CH > 96) AND (CH < 123) THEN LET CH = CH-32:X$ = CHR$(CH)
  86. 710 X=POS(0):Y=CSRLIN
  87. 720 IF LEN(X$) = 2 GOTO 780
  88. 730 IF ASC(X$) = 13 THEN X=1:Y=Y+4:IF Y>16 THEN Y=4:GOTO 760 ELSE GOTO 760 'NL
  89. 740 IF ASC(X$) = 8 THEN X = X-1:IF X < 1 THEN X=80:GOTO 760 ELSE GOTO 760 'BKSP
  90. 750 GOSUB 960
  91. 760 LOCATE Y,X,1
  92. 770 GOTO 680   'GOTO GET THE NEXT CHARACTER
  93. 780 ' Cursor Ctl.  Which?
  94. 790 Z = (ASC(MID$(X$,2,1))-70)
  95. 792 IF Z < 1 GOTO 760
  96. 794 IF Z > 10 GOTO 760
  97. 800 ON Z GOSUB  855,860,850,850,890,850,910,920,930,940
  98. 810 '            71   72   73   74   75   76   77   78   79   80   81
  99. 820 '           home  up            left      right          down
  100. 830 GOTO 760
  101. 840 ' ***** ROUTINE TO MOVE THE CURSOR AROUND *****
  102. 850 RETURN                                'no routine
  103. 855 X=1:Y=4                                'home
  104. 856 RETURN
  105. 860 Y=Y-4:IF Y < 4 THEN Y=16: RETURN       'cursor up
  106. 870 RETURN                                'page up
  107. 880 RETURN                                'unused
  108. 890 X= X-1:IF X = 0  THEN X = 80 :RETURN  'cursor left
  109. 900 RETURN                                'unused
  110. 910 X=X+1:IF X>80 THEN X = 1:RETURN       'cursor right
  111. 920 RETURN                                'unused
  112. 930 RETURN                                'end
  113. 940 Y=Y+4:IF Y > 16 THEN Y=4:RETURN       'cursor down
  114. 950 RETURN
  115. 960 '******   DECODE ROUTINE.  Verify that itis a permissable character *******
  116. 970 Q=(Y*160)-160+(X*2)-2
  117. 980 PREV$=CHR$(PEEK(Q))
  118. 990 IF (ASC(PREV$) >= 65) AND (ASC(PREV$) <= 90) THEN LOCC =(ASC(PREV$) - 64)*3:LOCATE 23,LOCC:PRINT PREV$;
  119. 1000 IF (ASC(X$) >= 65) AND (ASC(X$) <= 90) THEN LOCC =(ASC(X$) - 64)*3:LOCATE 23,LOCC:IF PEEK((22*160)+(LOCC*2)-2) = 32 THEN BEEP:GOTO 1040 ELSE PRINT " ":LOCATE Y,X,1:PRINT X$
  120. 1010 POKE Q+1,10
  121. 1020 R=Q+160
  122. 1030 FOR P=1 TO 4:GOSUB 1050:NEXT P   'chk 4 lines of code
  123. 1040 RETURN
  124. 1048 '******   DECODE ROUTINE.  Replace the code on each line.  *******
  125. 1050 IF LEN(CRYPTO$) <= (P-1)*80  THEN P=4:GOTO 1120 ELSE S=P*640
  126. 1060 FOR ZX = S TO S+158 STEP 2
  127. 1100 IF PEEK(R) = PEEK(ZX) THEN POKE ZX-160,ASC(X$):POKE ZX-159,10
  128. 1110 NEXT
  129. 1120 RETURN
  130. 1128 ' ******  GET THE CRYPTOGRAM FROM THE DISK  ******
  131. 1130 OPEN "CRYPDATA" AS #1 LEN=256
  132. 1140 FIELD #1, 255 AS C$
  133. 1150 LASTCR = LOF(1)/256
  134. 1160 LOCATE 7
  135. 1170 PRINT "          CHOOSE THE CRYPTOGRAM YOU WANT TO SOLVE          "
  136. 1180 PRINT
  137. 1190 PRINT "            RETURN  -  Will display the next Cryptogram.           "
  138. 1200 PRINT
  139. 1210 PRINT "            Number 1 to ... will display the one selected.         "
  140. 1220 PRINT
  141. 1230 PRINT "            Y - (Yes) will use the one displayed to decode.    "
  142. 1240 LOCATE 11,25,0
  143. 1250 PRINT LASTCR
  144. 1260 CNUM = LASTCR:GOTO 1290
  145. 1270 INPUT NUM$:NUM = VAL(NUM$):IF NUM > 0 THEN CNUM = NUM
  146. 1280 IF NUM$="y" OR  NUM$="Y" THEN CLOSE #1:GOTO 310
  147. 1290 GET #1, CNUM
  148. 1300 LET CRYPTO$ = C$
  149. 1310 LOCATE 15,1,0
  150. 1320 PRINT "==>"; CNUM; "of"; LASTCR;CRYPTO$
  151. 1330 CNUM = CNUM +1:IF CNUM <= LASTCR THEN GOTO 1270 ELSE CNUM = 1:GOTO 1270
  152. 1340 ' END OF THE PROGRAM
  153. "of"; LASTCR;CRYPTO$
  154. 1330 CNUM = CNUM +1:IF CNUM <= LASTCR THEN GOTO 1270 ELSE CNUM = 1:GOTO 1270
  155. 1340 '